perm filename CLEFXG.F4[NEW,LCS]9 blob
sn#423430 filedate 1979-03-07 generic text, type T, neo UTF8
00100 SUBROUTINE CLEFS
00200 COMMON /LIB/ KPNT1(10),K1,KPNT2(10),K2,KPNT3(10),K3,KPNT4(10),
00300 1 K4,KPNT5(10),K5,KPNT6(10),K6,KPNT7(10),K7,KPNT8(10),K8,
00400 1 JCLF1(350),JCLF2(350),JCLF3(350),JCLF4(350),
00500 1 JCLF5(350),JCLF6(350),JCLF7(350),JCLF8(350),
00600 1 NMX(1),NM2,NM3,NM4,NM5,NM6,NM7,NM8
00700 DIMENSION RCMIN(4),CM(4)
00800 COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS,XDIS/BM/F,G,H
00900 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /MIN/MINI,RMINI
01000 DATA RCMIN/3.3,10.5,7.0,10.5/,CM/.1,1.5,1.1,1.5/
01100 EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J9,JQ(7)),
01200 1 (R6,RJQ(4)),(R5,RJQ(3)),(R8,RJQ(6)),(R7,RJQ(5))
01300 1,(DEG,R9,RJQ(7)),(NJR,RJQ(8)),(R3,RJQ(1)),(J8,JQ(6))
01400 CX J5=MOD(J5,100)
01500 CX IF(J5)J5=-J5
01600 IF(R6.GE.100)R6=R6-100
01700 C SOMETIMES MAKE SIZE +100 FOR PARTS PROGRAM.
01800 CALL NOZERO(R6)
01900 IF(R7.EQ.0)R7=R6
02000 C IF P7 = 0, IT WILL EQUAL P6.
02100 IF(JA.GT.10)GO TO 9
02200 NAME='CLEFA'
02300 IF(J5.LT.20)GO TO 4
02400 R6=R6*.3
02500 C SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
02600 R7=R7*.3
02700 GO TO 4
02800 9 IF(NAME.EQ.NJR)GO TO 4
02900 IF(NAME.EQ.0)GO TO 177
03000 IF(NJR.EQ.0)GO TO 4
03100 177 IF(NJR.EQ.0)GO TO 8
03200 C TO PICK UP BASIC DRAW NAME FROM P10
03300 NAME=NJR
03400 GO TO 4
03500 8 TYPE 5
03600 5 FORMAT(' SET P10=1'/)
03700 C LEADS TO PROPER FILE CALL
03800 4 JTAIL=-1
03900 IF(JA.NE.3)GO TO 44
04000 IF(R5.NE.0.8)GO TO 44
04100 JTAIL=0
04200 C R5=0.8 FOR TREBLE CLEF WITH 8 ON TAIL. (FOR TENOR VOCAL)
04300 44 NM=NAME+2*(J5/10)
04400 C DRAW0 HAS ITEMS 0→9; DRAW1, 10→19; ETC. TO DRAW9, 90→99
04500 JEZ=MOD(J5,10)+1
04600 2 DO 200 K=1,8
04700 200 IF(NMX(K).EQ.NM)GO TO 30
04800 C SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
04900 C JUMP IF ALREADY IN CORE
05000 NPP=0
05100 IF(JA.NE.11)GO TO 1111
05200 C DOESN'T CHECK LOOKUP ON CLEFS AND ALPHA'S.
05300 NPP=-1
05400 IF(LOOKF(NM))GO TO 1111
05500 TYPE 1112,NM
05600 RETURN
05700 1112 FORMAT(1XA5,' -- NOT FOUND')
05800 KX=0
05900 1111 CALL GETFI2(NM,NPP)
06000 GO TO(33,233,333,433,533,633,733),KX
06100 C GOES TO 133 WHEN KX IS 0
06200 133 CALL FASTI2(KPNT1,11)
06300 CALL FASTI2(JCLF1,K1)
06400 C NEW DATA READER 6/74 -- 5/75 HOLDS 3 .DMD FILES IF THEY FIT.
06500 IF(K1.LE.350)GO TO 300
06600 C??? KX=0
06700 C??? NM2=0
06800 C??? GO TO 30
06900 GO TO 300
07000 33 CALL FASTI2(KPNT2,11)
07100 IF(K2.GT.350)GO TO 1112
07200 C JUMP BACK IF IT WON'T FIT.
07300 CALL FASTI2(JCLF2,K2)
07400 GO TO 300
07500 233 CALL FASTI2(KPNT3,11)
07600 IF(K3.GT.350)GO TO 1112
07700 C JUMP BACK IF IT WON'T FIT.
07800 CALL FASTI2(JCLF3,K3)
07900 C R6 IS SIZE FACTOR
08000 GO TO 300
08100 333 CALL FASTI2(KPNT4,11)
08200 IF(K4.GT.350)GO TO 1112
08300 C JUMP BACK IF IT WON'T FIT.
08400 CALL FASTI2(JCLF4,K4)
08500 GO TO 300
08600 433 CALL FASTI2(KPNT5,11)
08700 IF(K5.GT.350)GO TO 1112
08800 C JUMP BACK IF IT WON'T FIT.
08900 CALL FASTI2(JCLF5,K5)
09000 GO TO 300
09100 533 CALL FASTI2(KPNT6,11)
09200 IF(K6.GT.350)GO TO 1112
09300 C JUMP BACK IF IT WON'T FIT.
09400 CALL FASTI2(JCLF6,K6)
09500 GO TO 300
09600 633 CALL FASTI2(KPNT7,11)
09700 IF(K7.GT.350)GO TO 1112
09800 C JUMP BACK IF IT WON'T FIT.
09900 CALL FASTI2(JCLF7,K7)
10000 300 KX=KX+1
10100 NMX(KX)=NM
10200 GO TO 30
10300 733 CALL FASTI2(KPNT8,11)
10400 IF(K8.GT.350)GO TO 1112
10500 C JUMP BACK IF IT WON'T FIT.
10600 CALL FASTI2(JCLF8,K8)
10700 KX=0
10800 C RESET POINTER TO FIRST SLOT (NMX(1) )
10900 NMX(8)=NM
11000 30 IF(J5.GT.3)GO TO 811
11100 IF(JA.NE.3)GO TO 811
11200 C 0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP) MINI→R4+100
11300 C ↑↑↑↑↑↑↑↑ FIXUP SOMEDAY IN .DMD FILES
11400 IF(IABS(J4).LT.80)GO TO 812
11500 RSTJ2=.8*RSTJ2
11600 C TO SET HGT. OF MINI CLEFS
11700 R4=R4+CM(JEZ)
11800 C SHIFTS MINIS UP BECAUSE OF WRONG ORIG. POS.??
11900 812 IF(JEZ.NE.4)GO TO 811
12000 R4=R4+2
12100 JEZ=3
12200 C ABOVE IS NOW AT TOP
12300
12400 811 A=R4
12500 R4=A+2.9
12600 C ADJUSTS HEIGHT(??)
12700 CALL CENTX
12800 R4=A
12900
13000 DO 201 K=1,8
13100 201 IF(NM.EQ.NMX(K))L=KPNT1(JEZ+(K-1)*11)+350*(K-1)
13200 C ABOVE SETS POINTER TO LIBRARY STORAGE ARRAY.
13300 IF(L.LE.0)RETURN
13400 C CATCHES IMPOSSIBLE NUMBERS (I HOPE!)
13500 IF(J9.EQ.0)GO TO 31
13600 C***** ROTATE *******
13700 R7=R7*RSTJ2
13800 R6=R6*RSTJ2
13900 N=JCLF1(L)
14000 KNT=701
14100 C ROTATED DATA IS PUT STARTING AT LOCATION 701.(AREA FOR NM3)******
14200 JCLF1(KNT)=N
14300 DO 1 K=L+1,N+L-1
14400 CALL UNPACK(J,M,JCLF1(K))
14500 X=J*R6
14600 Y=M*R7
14700 JJ=JCLF1(K)/100000000
14800 AX=ATAN2(X,Y)*57.29578
14900 HYP=SQRT(X**2+Y**2)
15000 ROT=DEG+AX
15100 J=ROFF(HYP*COSD(ROT))
15200 M=ROFF(HYP*SIND(ROT))
15300 KNT=KNT+1
15400 IF(J)J=1000-J
15500 IF(M)M=1000-M
15600 1 JCLF1(KNT)=M*10000+J+JJ*100000000
15700 L=701
15800 C *********** SEE AT TOP **********
15900 R6=1.
16000 R7=1.
16100 RSTJ2=1.
16200 C SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
16300 NM3=0
16400 C WIPES OUT DATA AREA FOR NM3
16500 C R9=P9=DEGREES OF ROTATION (0-360)
16600 IF(KK.GT.350)KX=0
16700 C CHECK TO SEE IF DATA WAS WIPED OUT.
16800 31 A=-1
16900 C FLAG FOR THICKNESS OR NO.
17000 IF(J8.EQ.-2)GO TO 32
17100 IF(R8.LE.0)GO TO 34
17200 A=0
17300 C NEXT J8 = 1→99 =X THICKNESS, =100→ = Y THICKNESS
17400 CALL THICK
17500 C SEE CLEFZ.F4 FOR "THICK" CODE (THICK IS IN MFAIL.FAI)
17600 GO TO 32
17700 CC34 IF(IPLT)GO TO 77
17800 CC31 IF(R8.EQ.-2)GO TO 32
17900 C R8=-2 OMITS FILLER DURING PLOT
18000 CCC IF(IPLT)GO TO 77
18100 34 IF(IPLT)77,77,32
18200 CCCC IF(R8.NE.-1)GO TO 32
18300 77 DO 3 K=L+1,JCLF1(L)+L-1
18400 IF(JCLF1(K).LT.200000000)GO TO 3
18500 JEZ=JCLF1(L)-1
18600 IF(K.GT.L+1)JEZ=JEZ-K+L+1
18700 CALL FILLMS(JEZ,JCLF1(K),R3,CENTR,R6,R7)
18800 GO TO 32
18900 3 CONTINUE
19000 C FILLS ONLY WHEN PLOTING OR R8=-1
19100 32 CALL JDRAW(JCLF1(L),R3,CENTR,RSTJ2,R6,R7)
19200 C 3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, R8=-1 TO FILL ON CRT
19300 IF(A)GO TO 334
19400 IF(J8.NE.0)GO TO 234
19500 IF(J9.EQ.0)GO TO 334
19600 GO TO 134
19700 234 J8=J8-1
19800 R3=R3+XDIS
19900 C XDIS=1 PLOTTER STEP NO MATTER WHAT SIZE FACTOR USED
20000 134 IF(J9.EQ.0)GO TO 32
20100 J9=J9-1
20200 CENTR=CENTR+XDIS
20300 GO TO 32
20400 334 IF(JTAIL)RETURN
20500 JTAIL=-1
20600 JA=10
20700 JEZ=9
20800 C JEZ=9 MAKES AN 8 APPEAR UNDER TAIL OF TREBLE CLEF.
20900 R6=.2
21000 R7=R6
21100 NM='BDR40'
21200 R3=R3+14*RSTJ2
21300 R4=-4
21400 GO TO 2
21500 END